home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / MacPerl 506 appl folder.sit / MacPerl 506 appl folder / Mac_Perl_506r1m_appl / lib / IPC / Open2.pm next >
Text File  |  1995-03-20  |  2KB  |  65 lines
  1. die "Open2.pm not (yet) implemented on the Mac";
  2.  
  3. package IPC::Open2;
  4. require 5.000;
  5. require Exporter;
  6. use Carp;
  7.  
  8. @ISA = qw(Exporter);
  9. @EXPORT = qw(open2);
  10.  
  11. # &open2: tom christiansen, <tchrist@convex.com>
  12. #
  13. # usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
  14. #    or  $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
  15. #
  16. # spawn the given $cmd and connect $rdr for
  17. # reading and $wtr for writing.  return pid
  18. # of child, or 0 on failure.  
  19. # 
  20. # WARNING: this is dangerous, as you may block forever
  21. # unless you are very careful.  
  22. # 
  23. # $wtr is left unbuffered.
  24. # 
  25. # abort program if
  26. #    rdr or wtr are null
  27. #     pipe or fork or exec fails
  28.  
  29. $fh = 'FHOPEN000';  # package static in case called more than once
  30.  
  31. sub open2 {
  32.     local($kidpid);
  33.     local($dad_rdr, $dad_wtr, @cmd) = @_;
  34.  
  35.     $dad_rdr ne ''         || croak "open2: rdr should not be null";
  36.     $dad_wtr ne ''         || croak "open2: wtr should not be null";
  37.  
  38.     # force unqualified filehandles into callers' package
  39.     local($package) = caller;
  40.     $dad_rdr =~ s/^[^']+$/$package'$&/;
  41.     $dad_wtr =~ s/^[^']+$/$package'$&/;
  42.  
  43.     local($kid_rdr) = ++$fh;
  44.     local($kid_wtr) = ++$fh;
  45.  
  46.     pipe($dad_rdr, $kid_wtr)     || croak "open2: pipe 1 failed: $!";
  47.     pipe($kid_rdr, $dad_wtr)     || croak "open2: pipe 2 failed: $!";
  48.  
  49.     if (($kidpid = fork) < 0) {
  50.     croak "open2: fork failed: $!";
  51.     } elsif ($kidpid == 0) {
  52.     close $dad_rdr; close $dad_wtr;
  53.     open(STDIN,  "<&$kid_rdr");
  54.     open(STDOUT, ">&$kid_wtr");
  55.     warn "execing @cmd¥n" if $debug;
  56.     exec @cmd;
  57.     croak "open2: exec of @cmd failed";   
  58.     } 
  59.     close $kid_rdr; close $kid_wtr;
  60.     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
  61.     $kidpid;
  62. }
  63. 1; # so require is happy
  64.  
  65.